home *** CD-ROM | disk | FTP | other *** search
/ HPAVC / HPAVC CD-ROM.iso / TSPA3350.ZIP / TSUNTJ.TST < prev    next >
Text File  |  1993-06-30  |  3KB  |  118 lines
  1. (* This is a test program for the TSUNTJ.TPU unit *)
  2.  
  3. uses TSUNTJ,
  4.      TSUNTB;  { for the HEXFN in procedure TEST4 }
  5.  
  6. procedure LOGO;
  7. begin
  8.   writeln;
  9.   writeln ('TSUNTJ unit test by Prof. Timo Salmi, 30-Jun-93');
  10.   writeln ('University of Vaasa, Finland, ts@uwasa.fi');
  11. {$IFDEF VER40}
  12.   writeln ('TP version 4.0');
  13. {$ENDIF}
  14. {$IFDEF VER50}
  15.   writeln ('TP version 5.0');
  16. {$ENDIF}
  17. {$IFDEF VER55}
  18.   writeln ('TP version 5.5');
  19. {$ENDIF}
  20. {$IFDEF VER60}
  21.   writeln ('TP version 6.0');
  22. {$ENDIF}
  23. {$IFDEF VER70}
  24.   writeln ('TP version 7.0');
  25. {$ENDIF}
  26.   writeln;
  27. end;  (* logo *)
  28.  
  29. (* Testing copy *)
  30. procedure TEST1;
  31. var file1, file2 : string;
  32.     status       : byte;
  33. begin
  34.   file1 := 'c:\command.com';
  35.   file2 := 'r:\command.com';
  36.   COPYFILE (file1, file2, status);
  37.   if status = 0 then
  38.      writeln (file1, ' copied to ', file2)
  39.    else
  40.      begin
  41.        writeln ('Error in copying ', file1, ' to ', file2);
  42.        writeln ('Status = ', status);
  43.      end;
  44. end;  (* test1 *)
  45.  
  46. (* Testing if the given name is a directory *)
  47. procedure TEST2;
  48. var name : string;
  49.     b    : boolean;
  50. begin
  51.   name := ParamStr(1);
  52.   b := ISDIRFN (name);
  53.   writeln (name, ' is a directory: ', b);
  54.   b := ISDIR2FN (name);
  55.   writeln (name, ' is a directory: ', b);
  56. end;  (* test2 *)
  57.  
  58. (* Test where the standard input comes from, and where does the standard
  59.    output go to *)
  60. procedure TEST3;
  61. var s   : string;
  62.     con : text;
  63. begin
  64.   { We must have a way to write messages to the screen irrespective of
  65.     where the standard output is directed. }
  66.   assign (con, 'con');
  67.   rewrite (con);
  68.   {}
  69.   if PIPEDIFN then
  70.     writeln (con, 'Input from redirection')
  71.     else writeln (con, 'Input not from redirection');
  72.   {}
  73.   if PIPEDOFN then
  74.     writeln (con, 'Output redirected')
  75.     else writeln (con, 'Output not redirected');
  76.   {}
  77.   if PIPEDNFN then
  78.     writeln (con, 'Output redirected to nul')
  79.     else writeln (con, 'Output not redirected to nul');
  80.   {}
  81.   close (con);
  82. end;  (* test3 *)
  83.  
  84. (* Show interrupt information *)
  85. procedure TEST4;
  86. const intn : byte = $1F;  { graphics display character table }
  87. var segm, offs : word;
  88. begin
  89.   INTRLOCA (intn, segm, offs);
  90.   writeln ('Interrupt $', HEXFN(intn), ' is located at [',
  91.             HEXFN(segm),':$', HEXFN(offs), ']');
  92.   INTRADDR (intn, segm, offs);
  93.   writeln ('Interrupt $', HEXFN(intn), ' points to mem [',
  94.             HEXFN(segm),':$', HEXFN(offs), ']');
  95. end;  (* test4 *)
  96.  
  97. (* Test whether a name refers to a directory *)
  98. procedure TEST5;
  99. const name = 'r:\cmand';
  100. var b : boolean;
  101. begin
  102.   b := ISDIR3FN(name);
  103.   writeln (name, ' is a directory is ', b);
  104. end;  (* test5 *)
  105.  
  106. (* Main program *)
  107. begin
  108.   LOGO;
  109.   {      If you want test other than 2, remove the two bracket lines
  110.   TEST1;
  111.   TEST3;
  112.   TEST4;
  113.   TEST5;
  114.   write ('Press <═╝'); readln;
  115.   }
  116.   TEST2;
  117. end.  (* tsuntj.tst *)
  118.